home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
kcl
/
kcl.lha
/
c
/
read.d
< prev
next >
Wrap
Text File
|
1987-06-04
|
56KB
|
2,618 lines
/*
(c) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved.
Copying of this file is authorized to users who have executed the true and
proper "License Agreement for Kyoto Common LISP" with SIGLISP.
*/
/*
read.d
*/
#include "include.h"
#define token_buffer token->st.st_self
object standard_readtable;
object dispatch_reader;
object Vreadtable;
object Vread_default_float_format;
object Vread_base;
object Vread_suppress;
object Kstart;
object Kend;
object Kradix;
object Kjunk_allowed;
object READtable;
int READdefault_float_format;
int READbase;
bool READsuppress;
object siSsharp_comma;
bool preserving_whitespace_flag;
bool escape_flag;
object delimiting_char;
bool detect_eos_flag;
bool in_list_flag;
bool dot_flag;
object default_dispatch_macro;
object big_register_0;
#define cat(c) (READtable->rt.rt_self[char_code((c))] \
.rte_chattrib)
#define SHARP_EQ_CONTEXT_SIZE 64
setup_READtable()
{
READtable = current_readtable();
}
struct sharp_eq_context_struct {
object sharp_index;
object sharp_eq;
object sharp_sharp;
} sharp_eq_context[SHARP_EQ_CONTEXT_SIZE];
/*
NOTE:
I believe that there is no need to enter
sharp_eq_context to mark_origin.
*/
int sharp_eq_context_max;
setup_READ()
{
object x;
READtable = current_readtable();
x = symbol_value(Vread_default_float_format);
if (x == Sshort_float)
READdefault_float_format = 'S';
else if (x == Ssingle_float || x == Sdouble_float || x == Slong_float)
READdefault_float_format = 'F';
else {
vs_push(x);
Vread_default_float_format->s.s_dbind = Ssingle_float;
FEerror("The value of *READ-DEFAULT-FLOAT-FORMAT*, ~S, was illegal.",
1, x);
}
x = symbol_value(Vread_base);
if (type_of(x) != t_fixnum || fix(x) < 2 || fix(x) > 36) {
vs_push(x);
Vread_base->s.s_dbind = make_fixnum(10);
FEerror("The value of *READ-BASE*, ~S, was illegal.", 1, x);
}
READbase = fix(x);
READsuppress = symbol_value(Vread_suppress) != Cnil;
sharp_eq_context_max = 0;
backq_level = 0;
}
setup_standard_READ()
{
READtable = standard_readtable;
READdefault_float_format = 'F';
READbase = 10;
READsuppress = FALSE;
sharp_eq_context_max = 0;
backq_level = 0;
}
object
read_char(in)
object in;
{
return(code_char(readc_stream(in)));
}
#define read_char(in) code_char(readc_stream(in))
unread_char(c, in)
object c, in;
{
if (type_of(c) != t_character)
FEwrong_type_argument(Scharacter, c);
unreadc_stream(char_code(c), in);
}
/*
Peek_char corresponds to COMMON Lisp function PEEK-CHAR.
When pt is TRUE, preceeding whitespaces are ignored.
*/
object
peek_char(pt, in)
bool pt;
object in;
{
object c;
if (pt) {
do
c = read_char(in);
while (cat(c) == cat_whitespace);
unread_char(c, in);
return(c);
} else {
c = read_char(in);
unread_char(c, in);
return(c);
}
}
object
read_object_recursive(in)
{
object x;
bool e;
object old_READtable = READtable;
int old_READdefault_float_format = READdefault_float_format;
int old_READbase = READbase;
bool old_READsuppress = READsuppress;
/* BUG FIX by Toshiba */
vs_push(old_READtable);
frs_push(FRS_PROTECT, Cnil);
if (nlj_active) {
e = TRUE;
goto L;
}
READtable = current_readtable();
x = symbol_value(Vread_default_float_format);
if (x == Sshort_float)
READdefault_float_format = 'S';
else if (x == Ssingle_float || x == Sdouble_float || x == Slong_float)
READdefault_float_format = 'F';
else {
vs_push(x);
Vread_default_float_format->s.s_dbind = Ssingle_float;
FEerror("The value of *READ-DEFAULT-FLOAT-FORMAT*, ~S, was illegal.",
1, x);
}
x = symbol_value(Vread_base);
if (type_of(x) != t_fixnum || fix(x) < 2 || fix(x) > 36) {
vs_push(x);
Vread_base->s.s_dbind = make_fixnum(10);
FEerror("The value of *READ-BASE*, ~S, was illegal.", 1, x);
}
READbase = fix(x);
READsuppress = symbol_value(Vread_suppress) != Cnil;
x = read_object(in);
e = FALSE;
L:
frs_pop();
READtable = old_READtable;
READdefault_float_format = old_READdefault_float_format;
READbase = old_READbase;
READsuppress = old_READsuppress;
/* BUG FIX by Toshiba */
vs_pop;
if (e) {
nlj_active = FALSE;
unwind(nlj_fr, nlj_tag);
}
return(x);
}
object
read_object_non_recursive(in)
object in;
{
object x;
int i;
bool e;
object old_READtable;
int old_READdefault_float_format;
int old_READbase;
int old_READsuppress;
int old_sharp_eq_context_max;
struct sharp_eq_context_struct
old_sharp_eq_context[SHARP_EQ_CONTEXT_SIZE];
int old_backq_level;
old_READtable = READtable;
old_READdefault_float_format = READdefault_float_format;
old_READbase = READbase;
old_READsuppress = READsuppress;
old_sharp_eq_context_max = sharp_eq_context_max;
/* BUG FIX by Toshiba */
vs_push(old_READtable);
for (i = 0; i < sharp_eq_context_max; i++)
old_sharp_eq_context[i] = sharp_eq_context[i];
old_backq_level = backq_level;
setup_READ();
frs_push(FRS_PROTECT, Cnil);
if (nlj_active) {
e = TRUE;
goto L;
}
x = read_object(in);
vs_push(x);
if (sharp_eq_context_max > 0)
x = vs_head = patch_sharp(x);
e = FALSE;
L:
frs_pop();
READtable = old_READtable;
READdefault_float_format = old_READdefault_float_format;
READbase = old_READbase;
READsuppress = old_READsuppress;
sharp_eq_context_max = old_sharp_eq_context_max;
for (i = 0; i < sharp_eq_context_max; i++)
sharp_eq_context[i] = old_sharp_eq_context[i];
backq_level = old_backq_level;
if (e) {
nlj_active = FALSE;
unwind(nlj_fr, nlj_tag);
}
vs_pop;
/* BUG FIX by Toshiba */
vs_pop;
return(x);
}
object
standard_read_object_non_recursive(in)
object in;
{
object x;
int i;
bool e;
object old_READtable;
int old_READdefault_float_format;
int old_READbase;
int old_READsuppress;
int old_sharp_eq_context_max;
struct sharp_eq_context_struct
old_sharp_eq_context[SHARP_EQ_CONTEXT_SIZE];
int old_backq_level;
old_READtable = READtable;
old_READdefault_float_format = READdefault_float_format;
old_READbase = READbase;
old_READsuppress = READsuppress;
old_sharp_eq_context_max = sharp_eq_context_max;
/* BUG FIX by Toshiba */
vs_push(old_READtable);
for (i = 0; i < sharp_eq_context_max; i++)
old_sharp_eq_context[i] = sharp_eq_context[i];
old_backq_level = backq_level;
setup_standard_READ();
frs_push(FRS_PROTECT, Cnil);
if (nlj_active) {
e = TRUE;
goto L;
}
x = read_object(in);
vs_push(x);
if (sharp_eq_context_max > 0)
x = vs_head = patch_sharp(x);
e = FALSE;
L:
frs_pop();
READtable = old_READtable;
READdefault_float_format = old_READdefault_float_format;
READbase = old_READbase;
READsuppress = old_READsuppress;
sharp_eq_context_max = old_sharp_eq_context_max;
for (i = 0; i < sharp_eq_context_max; i++)
sharp_eq_context[i] = old_sharp_eq_context[i];
backq_level = old_backq_level;
if (e) {
nlj_active = FALSE;
unwind(nlj_fr, nlj_tag);
}
vs_pop;
/* BUG FIX by Toshiba */
vs_pop;
return(x);
}
/*
Read_object(in) reads an object from stream in.
This routine corresponds to COMMON Lisp function READ.
*/
object
read_object(in)
object in;
{
object x;
object c;
enum chattrib a;
object *old_vs_base;
object result;
object p;
int length, colon, colon_type;
int i, d;
bool df, ilf;
vs_mark;
cs_check(in);
vs_check_push(delimiting_char);
delimiting_char = OBJNULL;
df = detect_eos_flag;
detect_eos_flag = FALSE;
ilf = in_list_flag;
in_list_flag = FALSE;
dot_flag = FALSE;
BEGIN:
do {
if (stream_at_end(in)) {
if (df) {
vs_reset;
return(OBJNULL);
} else
end_of_stream(in);
}
c = read_char(in);
a = cat(c);
} while (a == cat_whitespace);
delimiting_char = vs_head;
if (delimiting_char != OBJNULL && c == delimiting_char) {
delimiting_char = OBJNULL;
vs_reset;
return(OBJNULL);
}
delimiting_char = OBJNULL;
if (a == cat_terminating || a == cat_non_terminating)
{
object *fun_box = vs_top;
old_vs_base = vs_base;
vs_push(Cnil);
vs_base = vs_top;
vs_push(in);
vs_push(c);
x =
READtable->rt.rt_self[char_code(c)].rte_macro;
fun_box[0] = x;
super_funcall(x);
i = vs_top - vs_base;
if (i == 0) {
vs_base = old_vs_base;
vs_top = old_vs_top + 1;
goto BEGIN;
}
if (i > 1) {
vs_push(make_fixnum(i));
FEerror("The readmacro ~S returned ~D values.",
2, fun_box[0], vs_top[-1]);
}
result = vs_base[0];
vs_base = old_vs_base;
vs_reset;
return(result);
}
escape_flag = FALSE;
length = 0;
colon_type = 0;
goto L;
for (;;) {
if (length >= token->st.st_dim)
too_long_token();
token_buffer[length++] = char_code(c);
K:
if (stream_at_end(in))
goto M;
c = read_char(in);
a = cat(c);
L:
if (a == cat_single_escape) {
c = read_char(in);
a = cat_constituent;
escape_flag = TRUE;
} else if (a == cat_multiple_escape) {
escape_flag = TRUE;
for (;;) {
if (stream_at_end(in))
end_of_stream(in);
c = read_char(in);
a = cat(c);
if (a == cat_single_escape) {
c = read_char(in);
a = cat_constituent;
} else if (a == cat_multiple_escape)
break;
if (length >= token->st.st_dim)
too_long_token();
token_buffer[length++] = char_code(c);
}
goto K;
} else if ('a' <= char_code(c) && char_code(c) <= 'z')
c = code_char(char_code(c) - ('a' - 'A'));
else if (char_code(c) == ':') {
if (colon_type == 0) {
colon_type = 1;
colon = length;
} else if (colon_type == 1 && colon == length-1)
colon_type = 2;
else
colon_type = -1;
/* Colon has appeared twice. */
}
if (a == cat_whitespace || a == cat_terminating)
break;
}
if (preserving_whitespace_flag || cat(c) != cat_whitespace)
unread_char(c, in);
M:
if (READsuppress) {
token->st.st_fillp = length;
vs_reset;
return(Cnil);
}
if (ilf && !escape_flag &&
length == 1 && token->st.st_self[0] == '.') {
dot_flag = TRUE;
vs_reset;
return(Cnil);
} else if (!escape_flag && length > 0) {
for (i = 0; i < length; i++)
if (token->st.st_self[i] != '.')
goto N;
FEerror("Dots appeared illegally.", 0);
}
N:
token->st.st_fillp = length;
if (escape_flag)
goto SYMBOL;
x = parse_number(token_buffer, length, &i, READbase);
if (x != OBJNULL && length == i) {
vs_reset;
return(x);
}
SYMBOL:
if (colon_type == 1 /* && length > colon + 1 */) {
if (colon == 0)
p = keyword_package;
else {
token->st.st_fillp = colon;
p = find_package(token);
if (p == Cnil) {
vs_push(copy_simple_string(token));
FEerror("There is no package with the name ~A.",
1, vs_head);
}
}
for (i = colon + 1; i < length; i++)
token_buffer[i - (colon + 1)]
= token_buffer[i];
token->st.st_fillp = length - (colon + 1);
if (colon > 0) {
x = find_symbol(token, p);
if (intern_flag != EXTERNAL) {
vs_push(copy_simple_string(token));
FEerror("Cannot find the external symbol ~A in ~S.",
2, vs_head, p);
/* no need to push a package */
}
vs_reset;
return(x);
}
} else if (colon_type == 2 /* && colon > 0 && length > colon + 2 */) {
token->st.st_fillp = colon;
p = find_package(token);
if (p == Cnil) {
vs_push(copy_simple_string(token));
FEerror("There is no package with the name ~A.",
1, vs_head);
}
for (i = colon + 2; i < length; i++)
token_buffer[i - (colon + 2)]
= token_buffer[i];
token->st.st_fillp = length - (colon + 2);
} else
p = current_package();
vs_push(p);
x = intern(token, p);
vs_push(x);
if (x->s.s_self == token_buffer) {
x->s.s_self = alloc_relblock(token->st.st_fillp);
for (i = 0; i < token->st.st_fillp; i++)
x->s.s_self[i] = token_buffer[i];
}
vs_reset;
return(x);
}
Lleft_parenthesis_reader()
{
object in, c, x;
object *p;
check_arg(2);
in = vs_base[0];
vs_head = Cnil;
p = &vs_head;
for (;;) {
delimiting_char = code_char(')');
in_list_flag = TRUE;
x = read_object(in);
if (x == OBJNULL)
goto ENDUP;
if (dot_flag) {
if (p == &vs_head)
FEerror("A dot appeared after a left parenthesis.", 0);
in_list_flag = TRUE;
*p = read_object(in);
if (dot_flag)
FEerror("Two dots appeared consecutively.", 0);
c = read_char(in);
while (cat(c) == cat_whitespace)
c = read_char(in);
if (char_code(c) != ')')
FEerror("A dot appeared before a right parenthesis.", 0);
goto ENDUP;
}
vs_push(x);
*p = make_cons(x, Cnil);
vs_pop;
p = &((*p)->c.c_cdr);
}
ENDUP:
vs_base[0] = vs_pop;
return;
}
#define is_exponent_marker(i) \
((i) == 'e' || (i) == 'E' || \
(i) == 's' || (i) == 'S' || (i) == 'f' || (i) == 'F' || \
(i) == 'd' || (i) == 'D' || (i) == 'l' || (i) == 'L' || \
(i) == 'b' || (i) == 'B')
/*
Parse_number(s, end, ep, radix) parses C string s
up to (but not including) s[end]
using radix as the radix for the rational number.
(For floating numbers, radix should be 10.)
When parsing has been succeeded,
the index of the next character is assigned to *ep,
and the number is returned as a lisp data object.
If not, OBJNULL is returned.
*/
object
parse_number(s, end, ep, radix)
char *s;
int end, *ep, radix;
{
object x, r;
fixnum sign;
struct bignum *integer_part;
double fraction, fraction_unit, f;
char exponent_marker;
int exponent;
int i, j, k;
int d;
vs_mark;
if (s[end-1] == '.')
radix = 10;
/*
DIRTY CODE!!
*/
BEGIN:
exponent_marker = 'E';
i = 0;
sign = 1;
if (s[i] == '+')
i++;
else if (s[i] == '-') {
sign = -1;
i++;
}
integer_part = (struct bignum *)big_register_0;
integer_part->big_car = 0;
integer_part->big_cdr = NULL;
vs_push((object)integer_part);
if (i >= end)
goto NO_NUMBER;
if (s[i] == '.') {
if (radix != 10) {
radix = 10;
goto BEGIN;
}
i++;
goto FRACTION;
}
if ((d = digitp(s[i], radix)) < 0)
goto NO_NUMBER;
do {
mul_int_big(radix, integer_part);
add_int_big(d, integer_part);
i++;
} while (i < end && (d = digitp(s[i], radix)) >= 0);
if (i >= end)
goto MAKE_INTEGER;
if (s[i] == '.') {
if (radix != 10) {
radix = 10;
goto BEGIN;
}
if (++i >= end)
goto MAKE_INTEGER;
else if (digitp(s[i], radix) >= 0)
goto FRACTION;
else if (is_exponent_marker(s[i])) {
fraction
= (double)sign * big_to_double(integer_part);
goto EXPONENT;
} else
goto MAKE_INTEGER;
}
if (s[i] == '/') {
i++;
goto DENOMINATOR;
}
if (is_exponent_marker(s[i])) {
fraction = (double)sign * big_to_double(integer_part);
goto EXPONENT;
}
/*
goto NO_NUMBER;
*/
MAKE_INTEGER:
if (sign < 0)
complement_big(integer_part);
x = normalize_big_to_object(integer_part);
/**/
if (x == big_register_0)
big_register_0 = alloc_object(t_bignum);
big_register_0->big.big_car = 0;
big_register_0->big.big_cdr = NULL;
/**/
goto END;
FRACTION:
/*
if (radix != 10)
goto NO_NUMBER;
*/
radix = 10;
if ((d = digitp(s[i], radix)) < 0)
goto NO_NUMBER;
fraction = 0.0;
fraction_unit = 0.000000001;
for (;;) {
k = j = 0;
do {
j = 10*j + d;
i++;
k++;
if (i < end)
d = digitp(s[i], radix);
else
break;
} while (k < 9 && d >= 0);
while (k++ < 9)
j *= 10;
fraction += fraction_unit * (double)j;
if (i >= end || d < 0)
break;
fraction_unit *= 0.000000001;
}
fraction += big_to_double(integer_part);
fraction *= (double)sign;
if (i >= end)
goto MAKE_FLOAT;
if (is_exponent_marker(s[i]))
goto EXPONENT;
goto MAKE_FLOAT;
EXPONENT:
/*
if (radix != 10)
goto NO_NUMBER;
*/
radix = 10;
exponent_marker = s[i];
i++;
if (i >= end)
goto NO_NUMBER;
sign = 1;
if (s[i] == '+')
i++;
else if (s[i] == '-') {
sign = -1;
i++;
}
if (i >= end)
goto NO_NUMBER;
if ((d = digitp(s[i], radix)) < 0)
goto NO_NUMBER;
exponent = 0;
do {
exponent = 10 * exponent + d;
i++;
} while (i < end && (d = digitp(s[i], radix)) >= 0);
d = exponent;
f = 10.0;
fraction_unit = 1.0;
while (d > 0)
if (d%2 == 0) {
d /= 2;
f *= f;
} else {
--d;
fraction_unit *= f;
}
if (sign > 0)
fraction *= fraction_unit;
else
fraction /= fraction_unit;
MAKE_FLOAT:
#ifdef IEEEFLOAT
if ((*(int *)&fraction & 0x7ff00000) == 0x7ff00000)
FEerror("Floating-point overflow.", 0);
#endif
switch (exponent_marker) {
case 'e': case 'E':
exponent_marker = READdefault_float_format;
goto MAKE_FLOAT;
case 's': case 'S':
x = make_shortfloat((shortfloat)fraction);
break;
case 'f': case 'F': case 'd': case 'D': case 'l': case 'L':
x = make_longfloat((longfloat)fraction);
break;
case 'b': case 'B':
goto NO_NUMBER;
}
/**/
big_register_0->big.big_car = 0;
big_register_0->big.big_cdr = NULL;
/**/
goto END;
DENOMINATOR:
if (sign < 0)
complement_big(integer_part);
vs_push(normalize_big_to_object(integer_part));
/**/
if (vs_head == big_register_0)
big_register_0 = alloc_object(t_bignum);
big_register_0->big.big_car = 0;
big_register_0->big.big_cdr = NULL;
/**/
if ((d = digitp(s[i], radix)) < 0)
goto NO_NUMBER;
integer_part = (struct bignum *)alloc_object(t_bignum);
integer_part->big_car = 0;
integer_part->big_cdr = NULL;
do {
mul_int_big(radix, integer_part);
add_int_big(d, integer_part);
i++;
} while (i < end && (d = digitp(s[i], radix)) >= 0);
vs_push(normalize_big_to_object(integer_part));
x = make_ratio(vs_top[-2], vs_top[-1]);
goto END;
END:
*ep = i;
vs_reset;
return(x);
NO_NUMBER:
*ep = i;
vs_reset;
/**/
big_register_0->big.big_car = 0;
big_register_0->big.big_cdr = NULL;
/**/
return(OBJNULL);
}
object
parse_integer(s, end, ep, radix)
char *s;
int end, *ep, radix;
{
object x, r;
fixnum sign;
struct bignum *integer_part;
int i, d;
vs_mark;
i = 0;
sign = 1;
if (s[i] == '+')
i++;
else if (s[i] == '-') {
sign = -1;
i++;
}
integer_part = (struct bignum *)big_register_0;
vs_push((object)integer_part);
if (i >= end)
goto NO_NUMBER;
if ((d = digitp(s[i], radix)) < 0)
goto NO_NUMBER;
do {
mul_int_big(radix, integer_part);
add_int_big(d, integer_part);
i++;
} while (i < end && (d = digitp(s[i], radix)) >= 0);
if (sign < 0)
complement_big(integer_part);
x = normalize_big_to_object(integer_part);
/**/
if (x == big_register_0)
big_register_0 = alloc_object(t_bignum);
big_register_0->big.big_car = 0;
big_register_0->big.big_cdr = NULL;
/**/
*ep = i;
vs_reset;
return(x);
NO_NUMBER:
*ep = i;
vs_reset;
/**/
big_register_0->big.big_car = 0;
big_register_0->big.big_cdr = NULL;
/**/
return(OBJNULL);
}
/*
Read_string(delim, in) reads
a simple string terminated by character code delim
and places it in token.
Delim is not included in the string but discarded.
*/
read_string(delim, in)
int delim;
object in;
{
int i;
object c;
i = 0;
for (;;) {
c = read_char(in);
if (char_code(c) == delim)
break;
else if (cat(c) == cat_single_escape)
c = read_char(in);
if (i >= token->st.st_dim)
too_long_string();
token_buffer[i++] = char_code(c);
}
token->st.st_fillp = i;
}
/*
Read_constituent(in) reads
a sequence of constituent characters from stream in
and places it in token_buffer.
*/
read_constituent(in)
object in;
{
int i, j;
object c;
i = 0;
for (;;) {
c = read_char(in);
if (cat(c) != cat_constituent) {
unread_char(c, in);
break;
}
j = char_code(c);
token_buffer[i++] = j;
}
token->st.st_fillp = i;
}
Ldouble_quote_reader()
{
check_arg(2);
vs_pop;
read_string('"', vs_base[0]);
vs_base[0] = copy_simple_string(token);
}
Ldispatch_reader()
{
object c, x;
int i, d;
object in;
check_arg(2);
in = vs_base[0];
c = vs_base[1];
if (READtable->rt.rt_self[char_code(c)].rte_dtab == NULL)
FEerror("~C is not a dispatching macro character", 1, c);
c = read_char(in);
d = digitp(char_code(c), 10);
if (d >= 0) {
i = 0;
do {
i = 10*i + d;
c = read_char(in);
d = digitp(char_code(c), 10);
} while (d >= 0);
vs_push(make_fixnum(i));
} else
vs_push(Cnil);
x =
READtable->rt.rt_self[char_code(vs_base[1])].rte_dtab[char_code(c)];
vs_base[1] = c;
super_funcall(x);
}
Lsingle_quote_reader()
{
check_arg(2);
vs_pop;
vs_push(Squote);
vs_push(read_object(vs_base[0]));
vs_push(Cnil);
stack_cons();
stack_cons();
vs_base[0] = vs_pop;
}
Lright_parenthesis_reader()
{
check_arg(2);
vs_pop;
vs_pop;
/* no result */
}
/*
Lcomma_reader(){}
*/
Lsemicolon_reader()
{
object c;
check_arg(2);
vs_pop;
do
c = read_char(vs_base[0]);
while (char_code(c) != '\n');
vs_pop;
vs_base[0] = Cnil;
/* no result */
}
/*
Lbackquote_reader(){}
*/
/*
sharpmacro routines
*/
Lsharp_C_reader()
{
object x, c;
check_arg(3);
if (vs_base[2] != Cnil && !READsuppress)
extra_argument('C');
vs_pop;
vs_pop;
c = read_char(vs_base[0]);
if (char_code(c) != '(')
FEerror("A left parenthesis is expected.", 0);
delimiting_char = code_char(')');
x = read_object(vs_base[0]);
if (x == OBJNULL)
FEerror("No real part.", 0);
vs_push(x);
delimiting_char = code_char(')');
x = read_object(vs_base[0]);
if (x == OBJNULL)
FEerror("No imaginary part.", 0);
vs_push(x);
delimiting_char = code_char(')');
x = read_object(vs_base[0]);
if (x != OBJNULL)
FEerror("A right parenthesis is expected.", 0);
if (contains_sharp_comma(vs_base[1]) ||
contains_sharp_comma(vs_base[2])) {
vs_base[0] = alloc_object(t_complex);
vs_base[0]->cmp.cmp_real = vs_base[1];
vs_base[0]->cmp.cmp_imag = vs_base[2];
} else {
check_type_number(&vs_base[1]);
check_type_number(&vs_base[2]);
vs_base[0] = make_complex(vs_base[1], vs_base[2]);
}
vs_top = vs_base + 1;
}
Lsharp_backslash_reader()
{
object c;
check_arg(3);
if (vs_base[2] != Cnil && !READsuppress)
if (type_of(vs_base[2]) != t_fixnum ||
fix(vs_base[2]) != 0)
FEerror("~S is an illegal CHAR-FONT.", 1, vs_base[2]);
/* assuming that CHAR-FONT-LIMIT is 1 */
vs_pop;
vs_pop;
unread_char(code_char('\\'), vs_base[0]);
if (READsuppress) {
(void)read_object(vs_base[0]);
vs_base[0] = Cnil;
return;
}
READsuppress = TRUE;
(void)read_object(vs_base[0]);
READsuppress = FALSE;
c = token;
if (c->s.s_fillp == 1) {
vs_base[0] = code_char(c->ust.ust_self[0]);
return;
}
if (string_equal(c, STreturn))
vs_base[0] = code_char('\r');
else if (string_equal(c, STspace))
vs_base[0] = code_char(' ');
else if (string_equal(c, STrubout))
vs_base[0] = code_char('\177');
else if (string_equal(c, STpage))
vs_base[0] = code_char('\f');
else if (string_equal(c, STtab))
vs_base[0] = code_char('\t');
else if (string_equal(c, STbackspace))
vs_base[0] = code_char('\b');
else if (string_equal(c, STlinefeed) || string_equal(c, STnewline))
vs_base[0] = code_char('\n');
else if (c->s.s_fillp == 2 && c->s.s_self[0] == '^')
vs_base[0] = code_char(c->s.s_self[1] & 037);
else if (c->s.s_self[0] =='\\' && c->s.s_fillp > 1) {
int i, n;
for (n = 0, i = 1; i < c->s.s_fillp; i++)
if (c->s.s_self[i] < '0' || '7' < c->s.s_self[i])
FEerror("Octal digit expected.", 0);
else
n = 8*n + c->s.s_self[i] - '0';
vs_base[0] = code_char(n & 0377);
} else
FEerror("~S is an illegal character name.", 1, c);
}
Lsharp_single_quote_reader()
{
check_arg(3);
if(vs_base[2] != Cnil && !READsuppress)
extra_argument('#');
vs_pop;
vs_pop;
vs_push(Sfunction);
vs_push(read_object(vs_base[0]));
vs_push(Cnil);
stack_cons();
stack_cons();
vs_base[0] = vs_pop;
}
#define QUOTE 1
#define EVAL 2
#define LIST 3
#define LISTA 4
#define APPEND 5
#define NCONC 6
object siScomma;
Lsharp_left_parenthesis_reader()
{
int dim;
int dimcount;
object in, x;
int a;
object *vsp;
check_arg(3);
if (vs_base[2] == Cnil || READsuppress)
dim = -1;
else if (type_of(vs_base[2]) == t_fixnum)
dim = fix(vs_base[2]);
vs_pop;
vs_pop;
in = vs_base[0];
if (backq_level > 0) {
unreadc_stream('(', in);
vs_push(read_object(in));
a = backq_car(vs_base[1]);
if (a == APPEND || a == NCONC)
FEerror(",at or ,. has appeared in an illegal position.", 0);
if (a == QUOTE) {
vsp = vs_top;
dimcount = 0;
for (x = vs_base[2]; !endp(x); x = x->c.c_cdr) {
vs_check_push(x->c.c_car);
dimcount++;
}
goto L;
}
vs_push(siScomma);
vs_push(Sapply);
vs_push(Squote);
vs_push(Svector);
vs_push(Cnil);
stack_cons();
stack_cons();
vs_push(vs_base[2]);
vs_push(Cnil);
stack_cons();
stack_cons();
stack_cons();
stack_cons();
vs_base = vs_top - 1;
return;
}
vsp = vs_top;
dimcount = 0;
for (;;) {
delimiting_char = code_char(')');
x = read_object(in);
if (x == OBJNULL)
break;
vs_check_push(x);
dimcount++;
}
L:
if (dim >= 0) {
if (dimcount > dim)
FEerror("Too many elements in #(...).", 0);
else {
if (dimcount == 0)
FEerror("Cannot fill the vector #().", 0);
x = vs_head;
for (; dimcount < dim; dimcount++)
vs_push(x);
}
}
x = alloc_simple_vector(dimcount, aet_object);
vs_push(x);
x->v.v_self
= (object *)alloc_relblock(dimcount * sizeof(object));
vs_pop;
for (dim = 0; dim < dimcount; dim++)
x->v.v_self[dim] = vsp[dim];
vs_top = vs_base;
vs_push(x);
}
Lsharp_asterisk_reader()
{
int dim;
int dimcount;
object in, x;
object *vsp;
check_arg(3);
if (READsuppress) {
read_constituent(vs_base[0]);
vs_pop;
vs_pop;
vs_base[0] = Cnil;
return;
}
if (vs_head == Cnil)
dim = -1;
else if (type_of(vs_head) == t_fixnum)
dim = fix(vs_head);
vs_pop;
vs_pop;
in = vs_head;
vsp = vs_top;
dimcount = 0;
for (;;) {
if (stream_at_end(in))
break;
x = read_char(in);
if (char_code(x) != '0' && char_code(x) != '1') {
unread_char(x, in);
break;
}
vs_check_push(x);
dimcount++;
}
if (dim >= 0) {
if (dimcount > dim)
FEerror("Too many elements in #*....", 0);
else {
if (dimcount == 0)
error("Cannot fill the bit-vector #*.");
x = vs_head;
for (; dimcount < dim; dimcount++)
vs_push(x);
}
}
x = alloc_simple_bitvector(dimcount);
vs_push(x);
x->bv.bv_self = alloc_relblock((dimcount + 7)/8);
vs_pop;
for (dim = 0; dim < dimcount; dim++)
if (char_code(vsp[dim]) == '0')
x->bv.bv_self[dim/8] &= ~(0200 >> dim%8);
else
x->bv.bv_self[dim/8] |= 0200 >> dim%8;
vs_top = vs_base;
vs_push(x);
}
Lsharp_colon_reader()
{
object in;
int length;
object c;
enum chattrib a;
if (vs_base[2] != Cnil && !READsuppress)
extra_argument(':');
vs_pop;
vs_pop;
in = vs_base[0];
c = read_char(in);
a = cat(c);
escape_flag = FALSE;
length = 0;
goto L;
for (;;) {
if (length >= token->st.st_dim)
too_long_token();
token_buffer[length++] = char_code(c);
K:
if (stream_at_end(in))
goto M;
c = read_char(in);
a = cat(c);
L:
if (a == cat_single_escape) {
c = read_char(in);
a = cat_constituent;
escape_flag = TRUE;
} else if (a == cat_multiple_escape) {
escape_flag = TRUE;
for (;;) {
if (stream_at_end(in))
end_of_stream(in);
c = read_char(in);
a = cat(c);
if (a == cat_single_escape) {
c = read_char(in);
a = cat_constituent;
} else if (a == cat_multiple_escape)
break;
if (length >= token->st.st_dim)
too_long_token();
token_buffer[length++] = char_code(c);
}
goto K;
} else if ('a' <= char_code(c) && char_code(c) <= 'z')
c = code_char(char_code(c) - ('a' - 'A'));
if (a == cat_whitespace || a == cat_terminating)
break;
}
if (preserving_whitespace_flag || cat(c) != cat_whitespace)
unread_char(c, in);
M:
if (READsuppress) {
vs_base[0] = Cnil;
return;
}
token->st.st_fillp = length;
vs_base[0] = copy_simple_string(token);
vs_base[0] = make_symbol(vs_base[0]);
}
Lsharp_dot_reader()
{
check_arg(3);
if(vs_base[2] != Cnil && !READsuppress)
extra_argument('.');
vs_pop;
vs_pop;
if (READsuppress) {
vs_base[0] = Cnil;
return;
}
vs_base[0] = read_object(vs_base[0]);
vs_base[0] = ieval(vs_base[0]);
}
Lsharp_comma_reader()
{
check_arg(3);
if(vs_base[2] != Cnil && !READsuppress)
extra_argument(',');
vs_pop;
vs_pop;
if (READsuppress) {
vs_base[0] = Cnil;
return;
}
vs_base[0] = read_object(vs_base[0]);
vs_base[0] = ieval(vs_base[0]);
}
siLsharp_comma_reader_for_compiler()
{
check_arg(3);
if(vs_base[2] != Cnil && !READsuppress)
extra_argument(',');
vs_pop;
vs_pop;
if (READsuppress) {
vs_base[0] = Cnil;
return;
}
vs_base[0] = read_object(vs_base[0]);
vs_base[0] = make_cons(siSsharp_comma, vs_base[0]);
}
/*
For fasload.
*/
Lsharp_exclamation_reader()
{
check_arg(3);
if(vs_base[2] != Cnil && !READsuppress)
extra_argument('!');
vs_pop;
vs_pop;
if (READsuppress) {
vs_base[0] = Cnil;
return;
}
vs_base[0] = read_object(vs_base[0]);
ieval(vs_base[0]);
vs_pop;
}
Lsharp_B_reader()
{
int i;
if(vs_base[2] != Cnil && !READsuppress)
extra_argument('B');
vs_pop;
vs_pop;
read_constituent(vs_base[0]);
if (READsuppress) {
vs_base[0] = Cnil;
return;
}
vs_base[0]
= parse_number(token_buffer, token->st.st_fillp, &i, 2);
if (vs_base[0] == OBJNULL || i != token->st.st_fillp)
FEerror("Cannot parse the #B readmacro.", 0);
if (type_of(vs_base[0]) == t_shortfloat ||
type_of(vs_base[0]) == t_longfloat)
FEerror("The float ~S appeared after the #B readmacro.",
1, vs_base[0]);
}
Lsharp_O_reader()
{
int i;
if(vs_base[2] != Cnil && !READsuppress)
extra_argument('O');
vs_pop;
vs_pop;
read_constituent(vs_base[0]);
if (READsuppress) {
vs_base[0] = Cnil;
return;
}
vs_base[0]
= parse_number(token_buffer, token->st.st_fillp, &i, 8);
if (vs_base[0] == OBJNULL || i != token->st.st_fillp)
FEerror("Cannot parse the #O readmacro.", 0);
if (type_of(vs_base[0]) == t_shortfloat ||
type_of(vs_base[0]) == t_longfloat)
FEerror("The float ~S appeared after the #O readmacro.",
1, vs_base[0]);
}
Lsharp_X_reader()
{
int i;
if(vs_base[2] != Cnil && !READsuppress)
extra_argument('X');
vs_pop;
vs_pop;
read_constituent(vs_base[0]);
if (READsuppress) {
vs_base[0] = Cnil;
return;
}
vs_base[0]
= parse_number(token_buffer, token->st.st_fillp, &i, 16);
if (vs_base[0] == OBJNULL || i != token->st.st_fillp)
FEerror("Cannot parse the #X readmacro.", 0);
if (type_of(vs_base[0]) == t_shortfloat ||
type_of(vs_base[0]) == t_longfloat)
FEerror("The float ~S appeared after the #X readmacro.",
1, vs_base[0]);
}
Lsharp_R_reader()
{
int radix, i;
check_arg(3);
if (READsuppress)
radix = 10;
else if (type_of(vs_base[2]) == t_fixnum) {
radix = fix(vs_base[2]);
if (radix > 36 || radix < 2)
FEerror("~S is an illegal radix.", 1, vs_base[2]);
} else
FEerror("No radix was supplied in the #R readmacro.", 0);
vs_pop;
vs_pop;
read_constituent(vs_base[0]);
if (READsuppress) {
vs_base[0] = Cnil;
return;
}
vs_base[0]
= parse_number(token_buffer, token->st.st_fillp, &i, radix);
if (vs_base[0] == OBJNULL || i != token->st.st_fillp)
FEerror("Cannot parse the #R readmacro.", 0);
if (type_of(vs_base[0]) == t_shortfloat ||
type_of(vs_base[0]) == t_longfloat)
FEerror("The float ~S appeared after the #R readmacro.",
1, vs_base[0]);
}
Lsharp_A_reader(){}
Lsharp_S_reader(){}
Lsharp_eq_reader()
{
int i;
check_arg(3);
if (READsuppress) {
vs_top = vs_base;
return;
}
if (vs_base[2] == Cnil)
FEerror("The #= readmacro requires an argument.", 0);
for (i = 0; i < sharp_eq_context_max; i++)
if (eql(sharp_eq_context[i].sharp_index, vs_base[2]))
FEerror("Duplicate definitions for #~D=.",
1, vs_base[2]);
if (sharp_eq_context_max >= SHARP_EQ_CONTEXT_SIZE)
FEerror("Too many #= definitions.", 0);
i = sharp_eq_context_max++;
sharp_eq_context[i].sharp_index = vs_base[2];
sharp_eq_context[i].sharp_sharp = OBJNULL;
vs_base[0]
= sharp_eq_context[i].sharp_eq
= read_object(vs_base[0]);
if (sharp_eq_context[i].sharp_eq
== sharp_eq_context[i].sharp_sharp)
FEerror("#~D# is defined by itself.",
1, sharp_eq_context[i].sharp_index);
vs_top = vs_base+1;
}
Lsharp_sharp_reader()
{
int i;
check_arg(3);
if (READsuppress) {
vs_pop;
vs_pop;
vs_base[0] = Cnil;
}
if (vs_base[2] == Cnil)
FEerror("The ## readmacro requires an argument.", 0);
for (i = 0; ; i++)
if (i >= sharp_eq_context_max)
FEerror("#~D# is undefined.", 1, vs_base[2]);
else if (eql(sharp_eq_context[i].sharp_index,
vs_base[2]))
break;
if (sharp_eq_context[i].sharp_sharp == OBJNULL) {
sharp_eq_context[i].sharp_sharp
= alloc_object(t_spice);
}
vs_base[0] = sharp_eq_context[i].sharp_sharp;
vs_top = vs_base+1;
}
patch_sharp_cons(x)
object x;
{
for (;;) {
x->c.c_car = patch_sharp(x->c.c_car);
if (type_of(x->c.c_cdr) == t_cons)
x = x->c.c_cdr;
else {
x->c.c_cdr = patch_sharp(x->c.c_cdr);
break;
}
}
}
object
patch_sharp(x)
object x;
{
cs_check(x);
switch (type_of(x)) {
case t_spice:
{
int i;
for (i = 0; i < sharp_eq_context_max; i++)
if (sharp_eq_context[i].sharp_sharp == x)
return(sharp_eq_context[i].sharp_eq);
break;
}
case t_cons:
/*
x->c.c_car = patch_sharp(x->c.c_car);
x->c.c_cdr = patch_sharp(x->c.c_cdr);
*/
patch_sharp_cons(x);
break;
case t_vector:
{
int i;
for (i = 0; i < x->v.v_fillp; i++)
x->v.v_self[i] = patch_sharp(x->v.v_self[i]);
break;
}
case t_array:
{
int i, j;
for (i = 0, j = 1; i < x->a.a_rank; i++)
j *= x->a.a_dims[i];
for (i = 0; i < j; i++)
x->a.a_self[i] = patch_sharp(x->a.a_self[i]);
break;
}
}
return(x);
}
Lsharp_plus_reader(){}
Lsharp_minus_reader(){}
Lsharp_less_than_reader(){}
Lsharp_whitespace_reader(){}
Lsharp_right_parenthesis_reader(){}
Lsharp_vertical_bar_reader()
{
int c;
int level = 0;
check_arg(3);
if (vs_base[2] != Cnil && !READsuppress)
extra_argument('|');
vs_pop;
vs_pop;
for (;;) {
c = readc_stream(vs_base[0]);
L:
if (c == '#') {
c = readc_stream(vs_base[0]);
if (c == '|')
level++;
} else if (c == '|') {
c = readc_stream(vs_base[0]);
if (c == '#') {
if (level == 0)
break;
else
--level;
} else
goto L;
}
}
vs_pop;
vs_base[0] = Cnil;
/* no result */
}
Ldefault_dispatch_macro()
{
FEerror("The default dispatch macro signalled an error.", 0);
}
/*
#" ... " returns the pathname with namestring ... .
*/
Lsharp_double_quote_reader()
{
check_arg(3);
if (vs_base[2] != Cnil && !READsuppress)
extra_argument('"');
vs_pop;
unread_char(vs_base[1], vs_base[0]);
vs_pop;
vs_base[0] = read_object(vs_base[0]);
vs_base[0] = coerce_to_pathname(vs_base[0]);
}
/*
#$ fixnum returns a random-state with the fixnum
as its content.
*/
Lsharp_dollar_reader()
{
int i;
check_arg(3);
if (vs_base[2] != Cnil && !READsuppress)
extra_argument('$');
vs_pop;
vs_pop;
vs_base[0] = read_object(vs_base[0]);
if (type_of(vs_base[0]) != t_fixnum)
FEerror("Cannot make a random-state with the value ~S.",
1, vs_base[0]);
i = fix(vs_base[0]);
vs_base[0] = alloc_object(t_random);
vs_base[0]->rnd.rnd_value = i;
}
/*
readtable routines
*/
object
copy_readtable(from, to)
object from, to;
{
struct rtent *rtab;
int i, j;
vs_mark;
if (to == Cnil) {
to = alloc_object(t_readtable);
to->rt.rt_self = NULL;
/* For GBC not to go mad. */
vs_push(to);
/* Saving for GBC. */
to->rt.rt_self
= rtab
= (struct rtent *)
alloc_contblock(RTABSIZE * sizeof(struct rtent));
for (i = 0; i < RTABSIZE; i++)
rtab[i] = from->rt.rt_self[i];
/* structure assignment */
}
for (i = 0; i < RTABSIZE; i++)
if (rtab[i].rte_dtab != NULL) {
rtab[i].rte_dtab
= (object *)
alloc_contblock(RTABSIZE * sizeof(object));
for (j = 0; j < RTABSIZE; j++)
rtab[i].rte_dtab[j]
= from->rt.rt_self[i].rte_dtab[j];
}
vs_reset;
return(to);
}
object
current_readtable()
{
object r;
r = symbol_value(Vreadtable);
if (type_of(r) != t_readtable) {
Vreadtable->s.s_dbind = copy_readtable(standard_readtable);
FEerror("The value of *READTABLE*, ~S, was not a readtable.",
1, r);
}
return(r);
}
@(defun read (&optional (strm `symbol_value(Vstandard_input)`)
(eof_errorp Ct)
eof_value
recursivep
&aux x)
@
if (strm == Cnil)
strm = symbol_value(Vstandard_input);
else if (strm == Ct)
strm = symbol_value(Vterminal_io);
check_type_stream(&strm);
if (recursivep == Cnil)
preserving_whitespace_flag = FALSE;
detect_eos_flag = TRUE;
if (recursivep == Cnil)
x = read_object_non_recursive(strm);
else
x = read_object_recursive(strm);
if (x == OBJNULL) {
if (eof_errorp == Cnil && recursivep == Cnil)
@(return eof_value)
end_of_stream(strm);
}
@(return x)
@)
@(defun read_preserving_whitespace
(&optional (strm `symbol_value(Vstandard_input)`)
(eof_errorp Ct)
eof_value
recursivep
&aux x)
object c;
@
if (strm == Cnil)
strm = symbol_value(Vstandard_input);
else if (strm == Ct)
strm = symbol_value(Vterminal_io);
check_type_stream(&strm);
while (!stream_at_end(strm)) {
c = read_char(strm);
if (cat(c) != cat_whitespace) {
unread_char(c, strm);
goto READ;
}
}
if (eof_errorp == Cnil && recursivep == Cnil)
@(return eof_value)
end_of_stream(strm);
READ:
if (recursivep == Cnil)
preserving_whitespace_flag = TRUE;
if (recursivep == Cnil)
x = read_object_non_recursive(strm);
else
x = read_object_recursive(strm);
@(return x)
@)
@(defun read_delimited_list
(d
&optional (strm `symbol_value(Vstandard_input)`)
recursivep
&aux l x)
object *p;
int i;
bool e;
int old_sharp_eq_context_max;
struct sharp_eq_context_struct
old_sharp_eq_context[SHARP_EQ_CONTEXT_SIZE];
int old_backq_level;
@
check_type_character(&d);
if (strm == Cnil)
strm = symbol_value(Vstandard_input);
else if (strm == Ct)
strm = symbol_value(Vterminal_io);
check_type_stream(&strm);
if (recursivep == Cnil) {
old_sharp_eq_context_max = sharp_eq_context_max;
for (i = 0; i < sharp_eq_context_max; i++)
old_sharp_eq_context[i] = sharp_eq_context[i];
old_backq_level = backq_level;
setup_READ();
frs_push(FRS_PROTECT, Cnil);
if (nlj_active) {
e = TRUE;
goto L;
}
}
l = Cnil;
p = &l;
preserving_whitespace_flag = FALSE; /* necessary? */
for (;;) {
delimiting_char = d;
x = read_object_recursive(strm);
if (x == OBJNULL)
break;
*p = make_cons(x, Cnil);
p = &((*p)->c.c_cdr);
}
if (recursivep == Cnil) {
if (sharp_eq_context_max > 0)
l = patch_sharp(l);
e = FALSE;
L:
frs_pop();
sharp_eq_context_max = old_sharp_eq_context_max;
for (i = 0; i < sharp_eq_context_max; i++)
sharp_eq_context[i] = old_sharp_eq_context[i];
backq_level = old_backq_level;
if (e) {
nlj_active = FALSE;
unwind(nlj_fr, nlj_tag);
}
}
@(return l)
@)
@(defun read_line (&optional (strm `symbol_value(Vstandard_input)`)
(eof_errorp Ct)
eof_value
recursivep
&aux c)
int i;
@
if (strm == Cnil)
strm = symbol_value(Vstandard_input);
else if (strm == Ct)
strm = symbol_value(Vterminal_io);
check_type_stream(&strm);
if (stream_at_end(strm)) {
if (eof_errorp == Cnil && recursivep == Cnil)
@(return eof_value)
else
end_of_stream(strm);
}
i = 0;
for (;;) {
c = read_char(strm);
if (char_code(c) == '\n') {
c = Cnil;
break;
}
if (i >= token->st.st_dim)
too_long_string();
token->st.st_self[i++] = char_code(c);
if (stream_at_end(strm)) {
c = Ct;
break;
}
}
token->st.st_fillp = i;
@(return `copy_simple_string(token)` c)
@)
@(defun read_char (&optional (strm `symbol_value(Vstandard_input)`)
(eof_errorp Ct)
eof_value
recursivep)
@
if (strm == Cnil)
strm = symbol_value(Vstandard_input);
else if (strm == Ct)
strm = symbol_value(Vterminal_io);
check_type_stream(&strm);
if (stream_at_end(strm)) {
if (eof_errorp == Cnil && recursivep == Cnil)
@(return eof_value)
else
end_of_stream(strm);
}
@(return `read_char(strm)`)
@)
@(defun unread_char (c &optional (strm `symbol_value(Vstandard_input)`))
@
check_type_character(&c);
if (strm == Cnil)
strm = symbol_value(Vstandard_input);
else if (strm == Ct)
strm = symbol_value(Vterminal_io);
check_type_stream(&strm);
unread_char(c, strm);
@(return Cnil)
@)
@(defun peek_char (&optional peek_type
(strm `symbol_value(Vstandard_input)`)
(eof_errorp Ct)
eof_value
recursivep)
object c;
@
if (strm == Cnil)
strm = symbol_value(Vstandard_input);
else if (strm == Ct)
strm = symbol_value(Vterminal_io);
check_type_stream(&strm);
setup_READtable();
if (peek_type == Cnil) {
if (stream_at_end(strm)) {
if (eof_errorp == Cnil && recursivep == Cnil)
@(return eof_value)
else
end_of_stream(strm);
}
c = read_char(strm);
unread_char(c, strm);
@(return c)
}
if (peek_type == Ct) {
while (!stream_at_end(strm)) {
c = read_char(strm);
if (cat(c) != cat_whitespace) {
unread_char(c, strm);
@(return c)
}
}
if (eof_errorp == Cnil)
@(return eof_value)
else
end_of_stream(strm);
}
check_type_character(&peek_type);
while (!stream_at_end(strm)) {
c = read_char(strm);
if (char_eq(c, peek_type)) {
unread_char(c, strm);
@(return c)
}
}
if (eof_errorp == Cnil)
@(return eof_value)
else
end_of_stream(strm);
@)
@(defun listen (&optional (strm `symbol_value(Vstandard_input)`))
@
if (strm == Cnil)
strm = symbol_value(Vstandard_input);
else if (strm == Ct)
strm = symbol_value(Vterminal_io);
check_type_stream(&strm);
if (listen_stream(strm))
@(return Ct)
else
@(return Cnil)
@)
@(defun read_char_no_hang (&optional (strm `symbol_value(Vstandard_input)`)
(eof_errorp Ct)
eof_value
recursivep)
@
if (strm == Cnil)
strm = symbol_value(Vstandard_input);
else if (strm == Ct)
strm = symbol_value(Vterminal_io);
check_type_stream(&strm);
if (!listen_stream(strm))
/* Incomplete! */
@(return Cnil)
@(return `read_char(strm)`)
@)
@(defun clear_input (&optional (strm `symbol_value(Vstandard_input)`))
@
if (strm == Cnil)
strm = symbol_value(Vstandard_input);
else if (strm == Ct)
strm = symbol_value(Vterminal_io);
check_type_stream(&strm);
@(return Cnil)
@)
@(defun parse_integer (strng
&key start
end
(radix `make_fixnum(10)`)
junk_allowed
&aux x)
int s, e, ep;
@
check_type_string(&strng);
get_string_start_end(strng, start, end, &s, &e);
if (type_of(radix) != t_fixnum ||
fix(radix) < 2 || fix(radix) > 36)
FEerror("~S is an illegal radix.", 1, radix);
setup_READtable();
while (READtable->rt.rt_self[strng->st.st_self[s]].rte_chattrib
== cat_whitespace && s < e)
s++;
if (s >= e) {
if (junk_allowed != Cnil)
@(return Cnil `make_fixnum(s)`)
else
goto CANNOT_PARSE;
}
x = parse_integer(strng->st.st_self+s, e-s, &ep, fix(radix));
if (x == OBJNULL) {
if (junk_allowed != Cnil)
@(return Cnil `make_fixnum(ep+s)`)
else
goto CANNOT_PARSE;
}
if (junk_allowed != Cnil)
@(return x `make_fixnum(ep+s)`)
for (s += ep ; s < e; s++)
if (READtable->rt.rt_self[strng->st.st_self[s]]
.rte_chattrib
!= cat_whitespace)
goto CANNOT_PARSE;
@(return x `make_fixnum(e)`)
CANNOT_PARSE:
FEerror("Cannot parse an integer in the string ~S.", 1, strng);
@)
@(defun read_byte (binary_input_stream
&optional eof_errorp eof_value)
int c;
@
check_type_stream(&binary_input_stream);
if (stream_at_end(binary_input_stream)) {
if (eof_errorp == Cnil)
@(return eof_value)
else
end_of_stream(binary_input_stream);
}
c = readc_stream(binary_input_stream);
@(return `make_fixnum(c)`)
@)
@(defun copy_readtable (&o (from `current_readtable()`) to)
@
if (from == Cnil) {
from = standard_readtable;
if (to != Cnil)
check_type_readtable(&to);
to = copy_readtable(from, to);
to->rt.rt_self['#'].rte_dtab['!']
= default_dispatch_macro;
/* We must forget #! macro. */
@(return to)
}
check_type_readtable(&from);
if (to != Cnil)
check_type_readtable(&to);
@(return `copy_readtable(from, to)`)
@)
Lreadtablep()
{
check_arg(1);
if (type_of(vs_base[0]) == t_readtable)
vs_base[0] = Ct;
else
vs_base[0] = Cnil;
}
@(defun set_syntax_from_char (tochr fromchr
&o (tordtbl `current_readtable()`)
fromrdtbl)
int i;
@
check_type_character(&tochr);
check_type_character(&fromchr);
check_type_readtable(&tordtbl);
if (fromrdtbl == Cnil)
fromrdtbl = standard_readtable;
else
check_type_readtable(&fromrdtbl);
tordtbl->rt.rt_self[char_code(tochr)].rte_chattrib
= fromrdtbl->rt.rt_self[char_code(fromchr)].rte_chattrib;
tordtbl->rt.rt_self[char_code(tochr)].rte_macro
= fromrdtbl->rt.rt_self[char_code(fromchr)].rte_macro;
if ((tordtbl->rt.rt_self[char_code(tochr)].rte_dtab
= fromrdtbl->rt.rt_self[char_code(fromchr)].rte_dtab)
!= NULL) {
tordtbl->rt.rt_self[char_code(tochr)].rte_dtab
= (object *)
alloc_contblock(RTABSIZE * sizeof(object));
for (i = 0; i < RTABSIZE; i++)
tordtbl->rt.rt_self[char_code(tochr)]
.rte_dtab[i]
= fromrdtbl->rt.rt_self[char_code(fromchr)]
.rte_dtab[i];
}
@(return Ct)
@)
@(defun set_macro_character (chr fnc
&optional ntp
(rdtbl `current_readtable()`))
int c;
@
check_type_character(&chr);
check_type_readtable(&rdtbl);
c = char_code(chr);
if (ntp != Cnil)
rdtbl->rt.rt_self[c].rte_chattrib
= cat_non_terminating;
else
rdtbl->rt.rt_self[c].rte_chattrib
= cat_terminating;
rdtbl->rt.rt_self[c].rte_macro = fnc;
@(return Ct)
@)
@(defun get_macro_character (chr &o (rdtbl `current_readtable()`))
object m;
@
check_type_character(&chr);
check_type_readtable(&rdtbl);
if ((m = rdtbl->rt.rt_self[char_code(chr)].rte_macro)
== OBJNULL)
@(return Cnil)
if (rdtbl->rt.rt_self[char_code(chr)].rte_chattrib
== cat_non_terminating)
@(return m Ct)
else
@(return m Cnil)
@)
@(defun make_dispatch_macro_character (chr
&optional ntp (rdtbl `current_readtable()`))
int i;
@
check_type_character(&chr);
check_type_readtable(&rdtbl);
if (ntp != Cnil)
rdtbl->rt.rt_self[char_code(chr)].rte_chattrib
= cat_non_terminating;
else
rdtbl->rt.rt_self[char_code(chr)].rte_chattrib
= cat_terminating;
rdtbl->rt.rt_self[char_code(chr)].rte_dtab
= (object *)
alloc_contblock(RTABSIZE * sizeof(object));
for (i = 0; i < RTABSIZE; i++)
rdtbl->rt.rt_self[char_code(chr)].rte_dtab[i]
= default_dispatch_macro;
rdtbl->rt.rt_self[char_code(chr)].rte_macro = dispatch_reader;
@(return Ct)
@)
@(defun set_dispatch_macro_character (dspchr subchr fnc
&optional (rdtbl `current_readtable()`))
@
check_type_character(&dspchr);
check_type_character(&subchr);
check_type_readtable(&rdtbl);
if (rdtbl->rt.rt_self[char_code(dspchr)].rte_macro != dispatch_reader
|| rdtbl->rt.rt_self[char_code(dspchr)].rte_dtab == NULL)
FEerror("~S is not a dispatch character.", 1, dspchr);
rdtbl->rt.rt_self[char_code(dspchr)]
.rte_dtab[char_code(subchr)] = fnc;
if ('a' <= char_code(subchr) && char_code(subchr) <= 'z')
rdtbl->rt.rt_self[char_code(dspchr)]
.rte_dtab[char_code(subchr) - ('a' - 'A')] = fnc;
@(return Ct)
@)
@(defun get_dispatch_macro_character (dspchr subchr
&optional (rdtbl `current_readtable()`))
@
check_type_character(&dspchr);
check_type_character(&subchr);
check_type_readtable(&rdtbl);
if (rdtbl->rt.rt_self[char_code(dspchr)].rte_macro != dispatch_reader
|| rdtbl->rt.rt_self[char_code(dspchr)].rte_dtab == NULL)
FEerror("~S is not a dispatch character.", 1, dspchr);
if (digitp(char_code(subchr),10) >= 0) @(return Cnil)
else @(return `rdtbl->rt.rt_self[char_code(dspchr)]
.rte_dtab[char_code(subchr)]`)
@)
object
string_to_object(x)
object x;
{
object in;
vs_mark;
in = make_string_input_stream(x, 0, x->st.st_fillp);
vs_push(in);
preserving_whitespace_flag = FALSE;
detect_eos_flag = FALSE;
x = read_object(in);
vs_reset;
return(x);
}
siLstring_to_object()
{
check_arg(1);
check_type_string(&vs_base[0]);
vs_base[0] = string_to_object(vs_base[0]);
}
siLstandard_readtable()
{
check_arg(0);
vs_push(standard_readtable);
}
too_long_token()
{
char *q;
int i;
q = alloc_contblock(token->st.st_dim*2);
for (i = 0; i < token->st.st_dim; i++)
q[i] = token->st.st_self[i];
token->st.st_self = q;
token->st.st_dim *= 2;
/*
token->st.st_fillp = token->st.st_dim;
FEerror("Too long a token: ~A.", 1, token);
*/
}
too_long_string()
{
char *q;
int i;
q = alloc_contblock(token->st.st_dim*2);
for (i = 0; i < token->st.st_dim; i++)
q[i] = token->st.st_self[i];
token->st.st_self = q;
token->st.st_dim *= 2;
/*
token->st.st_fillp = token->st.st_dim;
FEerror("Too long a string: ~S.", 1, token);
*/
}
extra_argument(c)
int c;
{
FEerror("~S is an extra argument for the #~C readmacro.",
2, vs_base[2], code_char(c));
}
#define make_cf(f) make_cfun((f), Cnil, Cnil, NULL, 0)
init_read()
{
struct rtent *rtab;
object *dtab;
int i;
standard_readtable = alloc_object(t_readtable);
enter_mark_origin(&standard_readtable);
standard_readtable->rt.rt_self
= rtab
= (struct rtent *)
alloc_contblock(RTABSIZE * sizeof(struct rtent));
for (i = 0; i < RTABSIZE; i++) {
rtab[i].rte_chattrib = cat_constituent;
rtab[i].rte_macro = OBJNULL;
rtab[i].rte_dtab = NULL;
}
dispatch_reader = make_cf(Ldispatch_reader);
enter_mark_origin(&dispatch_reader);
rtab['\t'].rte_chattrib = cat_whitespace;
rtab['\n'].rte_chattrib = cat_whitespace;
rtab['\f'].rte_chattrib = cat_whitespace;
rtab['\r'].rte_chattrib = cat_whitespace;
rtab[' '].rte_chattrib = cat_whitespace;
rtab['"'].rte_chattrib = cat_terminating;
rtab['"'].rte_macro = make_cf(Ldouble_quote_reader);
rtab['#'].rte_chattrib = cat_non_terminating;
rtab['#'].rte_macro = dispatch_reader;
rtab['\''].rte_chattrib = cat_terminating;
rtab['\''].rte_macro = make_cf(Lsingle_quote_reader);
rtab['('].rte_chattrib = cat_terminating;
rtab['('].rte_macro = make_cf(Lleft_parenthesis_reader);
rtab[')'].rte_chattrib = cat_terminating;
rtab[')'].rte_macro = make_cf(Lright_parenthesis_reader);
/*
rtab[','].rte_chattrib = cat_terminating;
rtab[','].rte_macro = make_cf(Lcomma_reader);
*/
rtab[';'].rte_chattrib = cat_terminating;
rtab[';'].rte_macro = make_cf(Lsemicolon_reader);
rtab['\\'].rte_chattrib = cat_single_escape;
/*
rtab['`'].rte_chattrib = cat_terminating;
rtab['`'].rte_macro = make_cf(Lbackquote_reader);
*/
rtab['|'].rte_chattrib = cat_multiple_escape;
/*
rtab['|'].rte_macro = make_cf(Lvertical_bar_reader);
*/
default_dispatch_macro = make_cf(Ldefault_dispatch_macro);
rtab['#'].rte_dtab
= dtab
= (object *)alloc_contblock(RTABSIZE * sizeof(object));
for (i = 0; i < RTABSIZE; i++)
dtab[i] = default_dispatch_macro;
dtab['C'] = dtab['c'] = make_cf(Lsharp_C_reader);
dtab['\\'] = make_cf(Lsharp_backslash_reader);
dtab['\''] = make_cf(Lsharp_single_quote_reader);
dtab['('] = make_cf(Lsharp_left_parenthesis_reader);
dtab['*'] = make_cf(Lsharp_asterisk_reader);
dtab[':'] = make_cf(Lsharp_colon_reader);
dtab['.'] = make_cf(Lsharp_dot_reader);
dtab['!'] = make_cf(Lsharp_exclamation_reader);
/* Used for fasload only. */
dtab[','] = make_cf(Lsharp_comma_reader);
dtab['B'] = dtab['b'] = make_cf(Lsharp_B_reader);
dtab['O'] = dtab['o'] = make_cf(Lsharp_O_reader);
dtab['X'] = dtab['x'] = make_cf(Lsharp_X_reader);
dtab['R'] = dtab['r'] = make_cf(Lsharp_R_reader);
/*
dtab['A'] = dtab['a'] = make_cf(Lsharp_A_reader);
dtab['S'] = dtab['s'] = make_cf(Lsharp_S_reader);
*/
dtab['A'] = dtab['a'] = make_si_ordinary("SHARP-A-READER");
dtab['S'] = dtab['s'] = make_si_ordinary("SHARP-S-READER");
dtab['='] = make_cf(Lsharp_eq_reader);
dtab['#'] = make_cf(Lsharp_sharp_reader);
dtab['+'] = make_cf(Lsharp_plus_reader);
dtab['-'] = make_cf(Lsharp_minus_reader);
/*
dtab['<'] = make_cf(Lsharp_less_than_reader);
*/
dtab['|'] = make_cf(Lsharp_vertical_bar_reader);
dtab['"'] = make_cf(Lsharp_double_quote_reader);
/* This is specific to this implimentation */
dtab['$'] = make_cf(Lsharp_dollar_reader);
/* This is specific to this implimentation */
/*
dtab[' '] = dtab['\t'] = dtab['\n'] = dtab['\f']
= make_cf(Lsharp_whitespace_reader);
dtab[')'] = make_cf(Lsharp_right_parenthesis_reader);
*/
init_backq();
Vreadtable
= make_special("*READTABLE*",
copy_readtable(standard_readtable, Cnil));
Vreadtable->s.s_dbind->rt.rt_self['#'].rte_dtab['!']
= default_dispatch_macro;
/* We must forget #! macro. */
Vread_default_float_format
= make_special("*READ-DEFAULT-FLOAT-FORMAT*",
Ssingle_float);
Vread_base = make_special("*READ-BASE*", make_fixnum(10));
Vread_suppress = make_special("*READ-SUPPRESS*", Cnil);
Kstart = make_keyword("START");
Kend = make_keyword("END");
Kradix = make_keyword("RADIX");
Kjunk_allowed = make_keyword("JUNK-ALLOWED");
READtable = symbol_value(Vreadtable);
enter_mark_origin(&READtable);
READdefault_float_format = 'F';
READbase = 10;
READsuppress = FALSE;
sharp_eq_context_max = 0;
siSsharp_comma = make_si_ordinary("#,");
enter_mark_origin(&siSsharp_comma);
delimiting_char = OBJNULL;
enter_mark_origin(&delimiting_char);
detect_eos_flag = FALSE;
in_list_flag = FALSE;
dot_flag = FALSE;
big_register_0 = alloc_object(t_bignum);
big_register_0->big.big_car = 0;
big_register_0->big.big_cdr = NULL;
enter_mark_origin(&big_register_0);
/*
NOTE:
The value of big_register_0 changes
along the execution of the read routines.
*/
}
init_read_function()
{
make_function("READ", Lread);
make_function("READ-PRESERVING-WHITESPACE",
Lread_preserving_whitespace);
make_function("READ-DELIMITED-LIST", Lread_delimited_list);
make_function("READ-LINE", Lread_line);
make_function("READ-CHAR", Lread_char);
make_function("UNREAD-CHAR", Lunread_char);
make_function("PEEK-CHAR", Lpeek_char);
make_function("LISTEN", Llisten);
make_function("READ-CHAR-NO-HANG", Lread_char_no_hang);
make_function("CLEAR-INPUT", Lclear_input);
make_function("PARSE-INTEGER", Lparse_integer);
make_function("READ-BYTE", Lread_byte);
make_function("COPY-READTABLE", Lcopy_readtable);
make_function("READTABLEP", Lreadtablep);
make_function("SET-SYNTAX-FROM-CHAR", Lset_syntax_from_char);
make_function("SET-MACRO-CHARACTER", Lset_macro_character);
make_function("GET-MACRO-CHARACTER", Lget_macro_character);
make_function("MAKE-DISPATCH-MACRO-CHARACTER",
Lmake_dispatch_macro_character);
make_function("SET-DISPATCH-MACRO-CHARACTER",
Lset_dispatch_macro_character);
make_function("GET-DISPATCH-MACRO-CHARACTER",
Lget_dispatch_macro_character);
make_si_function("SHARP-COMMA-READER-FOR-COMPILER",
siLsharp_comma_reader_for_compiler);
make_si_function("STRING-TO-OBJECT", siLstring_to_object);
make_si_function("STANDARD-READTABLE", siLstandard_readtable);
}
object
read_fasl_vector(in)
object in;
{
int dimcount, dim;
object *vsp;
object x;
int i;
bool e;
object old_READtable;
int old_READdefault_float_format;
int old_READbase;
int old_READsuppress;
int old_sharp_eq_context_max;
struct sharp_eq_context_struct
old_sharp_eq_context[SHARP_EQ_CONTEXT_SIZE];
int old_backq_level;
old_READtable = READtable;
old_READdefault_float_format = READdefault_float_format;
old_READbase = READbase;
old_READsuppress = READsuppress;
old_sharp_eq_context_max = sharp_eq_context_max;
/* BUG FIX by Toshiba */
vs_push(old_READtable);
for (i = 0; i < sharp_eq_context_max; i++)
old_sharp_eq_context[i] = sharp_eq_context[i];
old_backq_level = backq_level;
setup_standard_READ();
frs_push(FRS_PROTECT, Cnil);
if (nlj_active) {
e = TRUE;
goto L;
}
while (readc_stream(in) != '#')
;
while (readc_stream(in) != '(')
;
vsp = vs_top;
dimcount = 0;
for (;;) {
sharp_eq_context_max = 0;
backq_level = 0;
delimiting_char = code_char(')');
preserving_whitespace_flag = FALSE;
detect_eos_flag = FALSE;
x = read_object(in);
if (x == OBJNULL)
break;
vs_check_push(x);
if (sharp_eq_context_max > 0)
x = vs_head = patch_sharp(x);
dimcount++;
}
x = alloc_simple_vector(dimcount, aet_object);
vs_push(x);
x->v.v_self
= (object *)alloc_relblock(dimcount * sizeof(object));
for (dim = 0; dim < dimcount; dim++)
x->v.v_self[dim] = vsp[dim];
e = FALSE;
L:
frs_pop();
READtable = old_READtable;
READdefault_float_format = old_READdefault_float_format;
READbase = old_READbase;
READsuppress = old_READsuppress;
sharp_eq_context_max = old_sharp_eq_context_max;
for (i = 0; i < sharp_eq_context_max; i++)
sharp_eq_context[i] = old_sharp_eq_context[i];
backq_level = old_backq_level;
if (e) {
nlj_active = FALSE;
unwind(nlj_fr, nlj_tag);
}
vs_top = vsp;
return(x);
}